COMMENT ⊗   VALID 00012 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	ENTRY
C00003 00003	!	expr list => expr array 
C00004 00004	!	begin,cobegin,end,coend,if,for,while,do
C00010 00005	!	case
C00014 00006	! 	decl,simpledecl,arraydecl,procdecl,return
C00025 00007	!	setbase,wrist,gather,readwrist,setstiff
C00030 00008	! 	vt05,print,prompt,abort
C00032 00009	!	affix,unfix
C00035 00010	! 	coordproc
C00039 00011	!	assignproc
C00042 00012	! 	deflt
C00043 ENDMK
C⊗;
ENTRY;
BEGIN "PPROC"
DEFINE $$PRGID=TRUE;	DEFINE $PPROC=TRUE;	
REQUIRE "HEADER.SAI" SOURCE_FILE;


RCLASS EXPR$LST(RPTR(EXPR$) PTR; RPTR(EXPR$LST) NEXT);
RCLASS EXPR$ARR(RPTR(EXPR$) ARRAY PTR);

DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];


SIMPLE INTEGER PROCEDURE UPLEVEL(INTEGER OFFSET);
BEGIN
	INTEGER I;
	I ← (OFFSET +1) LSH -8	; ! this gives the level ;
	I ← (I+1) LSH 8		; ! this gives the next level ;
	RETURN(I-1);
END;
!	expr list => expr array ;
RPTR(EXPR$ARR) PROCEDURE ARRIFY(RPTR(EXPR$LST)PTR);
	BEGIN
	! takes a list of EXPR$ records and makes them into an array;
	INTEGER I,NRECS; RPTR(EXPR$LST)PPTR;
	NRECS←0; PPTR←PTR;
	WHILE PPTR DO BEGIN NRECS←NRECS+1; PPTR←EXPR$LST:NEXT[PPTR]; END;
		BEGIN
		RPTR(EXPR$)ARRAY P[1:NRECS];
		RPTR(EXPR$ARR) E;
		PPTR←PTR;
		FOR I←1 STEP 1 UNTIL NRECS DO
			BEGIN
			P[I]←EXPR$LST:PTR[PPTR];
			PPTR←EXPR$LST:NEXT[PPTR];
			END;
		E←NEW_RECORD(EXPR$ARR);
		MEMORY[LOCATION(EXPR$ARR:PTR[E])]↔MEMORY[LOCATION(P)];
		RETURN(E);
		END;
	END;

!	begin,cobegin,end,coend,if,for,while,do;

INTERNAL RECURSIVE PROCEDURE BEGINPROC;
BEGIN
	RPTR(EXPR$LST)E$HEAD,E$CUR; RPTR(BLOCKREC)B;
	INTEGER TMPOFF;
	$COMPILE←$COMPILE+1;
	$LEVEL←$LEVEL+1;
	TMPOFF←$TMPOFF;
	B←NEW_RECORD(BLOCKREC);
	BLOCKREC:NEXT[B]←CURBLOCK;
	CURBLOCK←B;
	E$HEAD←E$CUR←NEW_RECORD(EXPR$LST);
	DO BEGIN
		EXPR$LST:NEXT[E$CUR]←NEW_RECORD(EXPR$LST);
		E$CUR←EXPR$LST:NEXT[E$CUR];
		EXPR$LST:PTR[E$CUR]←PARSE;
		GTOKEN;
		IF TOKEN≠";" AND NOT EQU(TOKEN,"END")
			THEN ERROR("Need semicolon to separate statements");
	END UNTIL EQU(TOKEN,"END");
	! kill any new variables defined in this block ;
	EXPR$LST:PTR[EXPR$LST:NEXT[E$CUR]←NEW_RECORD(EXPR$LST)]←
			$KVARPCODE(BLOCKREC:#ARGS[CURBLOCK]);
	$$PCODE←$AAPPEND(EXPR$ARR:PTR[ARRIFY(EXPR$LST:NEXT[E$HEAD])]);
	CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
	$TMPOFF←TMPOFF;
	$LEVEL←$LEVEL-1;
	$COMPILE←$COMPILE-1;
END;

INTERNAL RECURSIVE PROCEDURE COBEGINPROC;
BEGIN
	RPTR(EXPR$LST)E$HEAD,E$CUR;
	INTEGER TMPOFF,N$TMPOFF;
	$COMPILE←$COMPILE+1;
	$LEVEL←$LEVEL+1;
	TMPOFF←$TMPOFF;
	N$TMPOFF←UPLEVEL($TMPOFF);
	E$HEAD←E$CUR←NEW_RECORD(EXPR$LST);
	DO BEGIN
		RPTR(BLOCKREC)B;
		B←NEW_RECORD(BLOCKREC);
		BLOCKREC:NEXT[B]←CURBLOCK;
		CURBLOCK←B;
		$TMPOFF←N$TMPOFF;
		EXPR$LST:NEXT[E$CUR]←NEW_RECORD(EXPR$LST);
		E$CUR←EXPR$LST:NEXT[E$CUR];
		EXPR$LST:PTR[E$CUR]←PARSE;
		CURBLOCK←BLOCKREC:NEXT[CURBLOCK];
		GTOKEN;
		IF TOKEN≠";" AND NOT EQU(TOKEN,"COEND")
			THEN ERROR("Need semicolon to separate statements");
	END UNTIL EQU(TOKEN,"COEND");
	$$PCODE←$COBEGPCODE(EXPR$ARR:PTR[ARRIFY(EXPR$LST:NEXT[E$HEAD])]);
	$TMPOFF←TMPOFF;
	$LEVEL←$LEVEL-1;
	$COMPILE←$COMPILE-1;
END;

INTERNAL PROCEDURE ENDPROC(STRING E("END"));
BEGIN
	IF $COMPILE=0 THEN ERROR("Encountered "&E&" as a statement.... strange");
	STOKEN←TRUE;
	$$PCODE←NULL_RECORD;
END;

INTERNAL RECURSIVE PROCEDURE IFPROC;
BEGIN
	RPTR(EXPR$)COND,A,B;
	$COMPILE←$COMPILE+1;
	COND←$$GTANYEXP("condition part of IF statement",#SC);
	WORD_READ("THEN");
	A←PARSE;
	GTOKEN;
	B←NULL_RECORD;
	IF EQU(TOKEN,"ELSE") THEN B←PARSE
		ELSE IF TOKEN=";" OR EQU (TOKEN, "END") THEN STOKEN←TRUE
		ELSE ERROR("Only ELSE or ; allowed after then part");
	$COMPILE←$COMPILE-1;
	$$PCODE←$IFPCODE(COND,A,B)
END;

INTERNAL RECURSIVE PROCEDURE FORPROC;
BEGIN
	RPTR(SYMBOL)S;
	RPTR(EXPR$)LB,UB,STE,STATE;
	$COMPILE←$COMPILE+1;
	GTOKEN;
	IF TOKENINDEX≠#SC THEN ERROR("Need scalar for FOR statement");
	S←TOKENPTR;
	WORD_READ("←");
	LB←$$GTANYEXP("FOR statement",#SC);
	WORD_READ("STEP");
	STE←$$GTANYEXP("FOR statement",#SC);
	WORD_READ("UNTIL");
	UB←$$GTANYEXP("FOR statement",#SC);
	WORD_READ("DO");
	STATE←PARSE;
	$$PCODE←$FORPCODE(S,LB,STE,UB,STATE);
	$COMPILE←$COMPILE-1;
END;

INTERNAL RECURSIVE PROCEDURE WHILEPROC;
BEGIN
	RPTR(EXPR$)COND,S;
	$COMPILE←$COMPILE+1;
	COND←$$GTANYEXP("condition part of WHILE statement",#SC);
	WORD_READ("DO");
	S←PARSE;
	$COMPILE←$COMPILE-1;
	$$PCODE←$WHILEPCODE(COND,S);
END;

INTERNAL RECURSIVE PROCEDURE DOPROC;
BEGIN
	RPTR(EXPR$)S,COND;
	$COMPILE←$COMPILE+1;
	S←PARSE;
	WORD_READ("UNTIL");
	COND←$$GTANYEXP("UNTIL part of DO statement",#SC);
	$$PCODE←$DOPCODE(S,COND);
	$COMPILE←$COMPILE-1;
END;

!	case;

RECURSIVE RPTR(CASE$) PROCEDURE CASE$REC (RPTR(CASE$)CASEXP;INTEGER NUM);
	BEGIN
	! creates a new record linked with casexp and fills in the
	num field the number num;
	RPTR(CASE$)TEMP;
	TEMP←NEW_RECORD(CASE$);
	CASE$:NEXT[TEMP]←CASEXP;
	CASE$:NUM[TEMP]←NUM;
	RETURN(TEMP);
	END;

RECURSIVE RPTR(CASE$)PROCEDURE CASE$EXP (RPTR(CASE$)CASEXP;RPTR(EXPR$)EXP);
	BEGIN
	! inserts the pointer expr in the field body of casexp;
	IF EXP= NULL!RECORD
	   THEN EXP←EXPR$1(XNOOP);
	CASE$:BODY[CASEXP]←EXP;
	RETURN(CASEXP);
	END;

INTERNAL RECURSIVE PROCEDURE CASEPROC;
	BEGIN
	RPTR(EXPR$)EXINDEX,EXS; RPTR(CASE$)EXCASE;
	BOOLEAN RDELSE;INTEGER MAXNUM;
	$COMPILE←$COMPILE+1;
	RDELSE←FALSE;MAXNUM←-1;
	EXCASE←NULL!RECORD;
	EXINDEX←$$GTANYEXP(" CASE", #SC);	! get index;
	WORD_READ("OF");
	WORD_READ("BEGIN");
	GTOKEN;STOKEN←TRUE;
	IF TOKEN="[" OR EQU(TOKEN,"ELSE")
	   THEN BEGIN "numbered"
		INTEGER NUM;
		DO BEGIN
		   GTOKEN;
		   IF EQU(TOKEN,"ELSE")
			THEN IF RDELSE THEN ERROR ("only one ELSE in CASE!")
				ELSE BEGIN 
				     RDELSE←TRUE;NUM←#ELSE;
				     END
		  	ELSE IF TOKEN="[" 
			   THEN BEGIN
				NUM←POSINT_READ;
				IF NUM>MAXNUM THEN MAXNUM←NUM;
				WORD_READ("]");
				END
			   ELSE ERROR("[ or ELSE expected");
		  ! construct the record with num or #else in field num;
		  EXCASE←CASE$REC(EXCASE,NUM);
		  GTOKEN;
		  STOKEN←TRUE;
		  IF TOKEN≠"[" AND ¬EQU(TOKEN,"ELSE")	
		     THEN BEGIN
			  EXS←PARSE;GTOKEN;
			  IF TOKEN≠";" AND ¬EQU(TOKEN,"END") 
				THEN ERROR("need ; or END");
			  EXCASE←CASE$EXP(EXCASE,EXS);
			  STOKEN←FALSE;
			  END;
		   END UNTIL EQU(TOKEN,"END");
		END "numbered"
		ELSE 
			WHILE ¬EQU(TOKEN,"END") DO 
			BEGIN "unnumbered"
			EXS←PARSE;
			GTOKEN;
			IF TOKEN≠";" AND ¬EQU(TOKEN,"END") 
				THEN ERROR("need ; or END");
			MAXNUM←MAXNUM+1;
	 	 	EXCASE←CASE$EXP(CASE$REC(EXCASE,MAXNUM),EXS);
			END "unnumbered";
	IF MAXNUM≠-1 THEN
		$$PCODE←$CASEPCODE(EXINDEX,EXCASE,RDELSE,MAXNUM);
   	$COMPILE←$COMPILE-1;
   	END;
! 	decl,simpledecl,arraydecl,procdecl,return;

INTERNAL PROCEDURE PROCDECLPROC(INTEGER OBTYPE(#PR));
	BEGIN "procedure declaration"
	STRING ATOKEN;INTEGER NARGS,SYMACCS;
	INTEGER TMPOFF;
	INTEGER ARRAY ACCESS,TYPE,ARRDIM,ARGOFF[1:10];
	STRING ARRAY ARGNAME[1:10];
	RPTR(SYMBOL) ARRAY SYMARR[1:10];
	RPTR(PROC)PSYM; RPTR(EXPR$)PBODY; RPTR(SYMBOL)SYM; RANY DATPTR;
	IF CURPROC THEN ERROR("Cant have procedure inside procedure");
	IF CURBLOCK THEN ERROR("Cant have procedure inside block");
	$COMPILE←$COMPILE+1; $LEVEL←1;
	GTOKEN;
	IF #TOKEN≠UNDECLARED_TYPE THEN
		ERROR("Need undeclared identifier for procedure declaration");
	ATOKEN←TOKEN;
	NARGS←0; TMPOFF←$TMPOFF; $TMPOFF←UPLEVEL(TMPOFF);! starting value ;
	GTOKEN;
	IF TOKEN="(" THEN
	    DO BEGIN "procedure with parameters"
		INTEGER CACCESS,CTYPE; BOOLEAN ARRDECL;
		GTOKEN;
		ARRDECL←FALSE;
		CACCESS←#REFTYP; SYMACCS←#SIMPLE;
		IF EQU(TOKEN,"VALUE") THEN CACCESS←0
			ELSE IF EQU(TOKEN,"REFERENCE") THEN CACCESS←#REFTYP
			ELSE STOKEN←TRUE;
		GTOKEN;
		FOR CTYPE←#SC STEP 1 UNTIL #FR DO
			IF EQU(TOKEN,$DTYPE[CTYPE]) THEN DONE;
		IF NOT(#SC≤CTYPE≤#FR) THEN ERROR("Need basic data type declaration here");
		GTOKEN;
		DATPTR←NULL_RECORD;
		IF EQU(TOKEN,"ARRAY") THEN
			BEGIN  CACCESS←#REFTYP+#ARRTYP;
				ARRDECL←TRUE; SYMACCS←#ARRAY;
			END ELSE STOKEN←TRUE;
		DO BEGIN "get list of parameters"
		   INTEGER I;
		   IF NARGS>10 THEN ERROR("Cant take more than 10 parameters");
		   GTOKEN;
				! now check if we have used this before ;
		   IF NOT(#TOKEN≠UNDECLARED_TYPE OR #TOKEN≠ID_TYPE) THEN
			ERROR("Need undeclared or id token here");
		   FOR I←1 STEP 1 UNTIL NARGS DO 
			IF EQU(TOKEN,ARGNAME[I]) THEN DONE;
		   IF EQU(TOKEN,ATOKEN) THEN I←NARGS;
		   IF I≠NARGS+1 THEN ERROR(TOKEN&" has already been used in this procedure");
		   NARGS←NARGS+1;
		   TYPE[NARGS]←CTYPE; ACCESS[NARGS]←CACCESS;
		   ARGNAME[NARGS]←TOKEN;
		   ARGOFF[NARGS]←($TMPOFF←$TMPOFF+1);
		   IF ARRDECL THEN
			BEGIN "array in argument list"
			  RPTR(EXPR$)E;
			  INTEGER I; I←0;
			  WORD_READ("[");
			  DO BEGIN "no of arguments"
			      E←$$GTANYEXP("for field of array declaration",#SC);
			      WORD_READ(":");
			      E←$$GTANYEXP("for dimension field of array dec",#SC);
			      I←I+1;
			      GTOKEN;
			      IF TOKEN≠"," AND TOKEN≠"]" THEN ERROR("Need , or ] here");
			    END "no of arguments" UNTIL TOKEN="]";
			IF I>5 THEN ERROR("Array dimension must be less than 5");
			ARRAYREC:#DIM[DATPTR←NEW_RECORD(ARRAYREC)]←ARRDIM[NARGS]←I;
			END "array in argument list";
		   SYMBOL:OFFSET[SYMARR[NARGS]←MK_SYM(ARGNAME[NARGS],
			TYPE[NARGS],DATPTR,SYMACCS)]	← $TMPOFF;
		   GTOKEN;
		   END "get list of parameters" UNTIL TOKEN≠",";
		   IF TOKEN≠")" AND TOKEN≠";" THEN ERROR("Need ; or , or ) here");
	    END "procedure with parameters" UNTIL TOKEN=")"
	ELSE STOKEN←TRUE;
	WORD_READ(";");
	PSYM←MK_PR(NARGS,ARGNAME,TYPE,ACCESS,ARRDIM);
	SYM←CURPROC←MK_SYM(ATOKEN,OBTYPE,PSYM,#PROCEDURE);
	SYMBOL:OFFSET[CURPROC]←$SYMOFF;
	CURBLOCK←BLOCKIFY(NARGS,SYMARR);
	BLOCKREC:LEVEL[CURBLOCK]←$LEVEL;
	PBODY←PARSE;
	PR_SAVE(PSYM,$CLNSAVE);
	$$PCODE←$PRCDCLPCODE(SYM,PBODY);
	ENSYM$(SYM);
	$SYMOFF←$SYMOFF+1;
	$COMPILE←$COMPILE-1;
END;

! parses the declaration instructions
		SCALAR <id>,<id>,...
		VECTOR <id>,<id>,...
		FRAME  <id>,<id>,...
		ROT    <id>,<id>,...;
INTERNAL PROCEDURE SIMPLEDECL(INTEGER OBTYPE);
	BEGIN
	RPTR(SYMBOL)ARRAY SPTR[1:10];
	INTEGER I,J; J←0;
	DO BEGIN "A"
	   IF J=10 THEN ERROR("Can only declare 10 variables in a declaration");
	   GTOKEN;     
	   IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
	     OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
	      THEN ERROR("undeclared identifier required")
 	      ELSE BEGIN "check current list"
			INTEGER K;
			FOR K←1 STEP 1 UNTIL J DO
				IF EQU(SYMBOL:PNAME[SPTR[K]],TOKEN) THEN DONE;
			IF K=J+1 THEN SPTR[J←J+1]←NNWR(TOKEN,OBTYPE)
				ELSE ERROR(TOKEN&" is not undeclared");
		   END "check current list";
	   GTOKEN(FALSE);
	   IF TOKEN≠"," AND NOT FINAL
	      THEN ERROR("; or , required");
	   END "A" UNTIL FINAL;
	IF CURBLOCK
	  THEN FOR I←1 STEP 1 UNTIL J DO 
		BEGIN INSRTSYMTREE(SPTR[I],CURBLOCK);
			SYMBOL:OFFSET[SPTR[I]]←($TMPOFF←$TMPOFF+1);
			$$PCODE←$SMPDCLPCODE(OBTYPE,J);
			STOKEN←TRUE;
		END
	  ELSE FOR I←1 STEP 1 UNTIL J DO ENSYM$(SPTR[I]);
	$DISPLAYLIST[OBTYPE]←NULL;
	END;

	! to handle array declarations;
INTERNAL PROCEDURE ARRAYDECLPROC(INTEGER OBTYPE);
    BEGIN "array declaration"
    RPTR(EXPR$)PARRAY;
    INTEGER NARRAY;
    RPTR(EXPR$) ARRAY PLIST[1:10];
    RPTR(SYMBOL) ARRAY SYMLST[1:10];
    NARRAY←0;
    DO BEGIN "get another one"
	STRING ATOKEN; INTEGER ADIM; RPTR(EXPR$)ARRAY BOUNDS[1:10];
	RPTR(ARRAYREC) DIMREC;
	IF NARRAY≥10 THEN ERROR("Can't have more than 10 variables in a declaration");
	ADIM←0; GTOKEN;
	IF (CURBLOCK=NULL_RECORD AND #TOKEN≠UNDECLARED_TYPE)
	  OR (CURBLOCK≠NULL_RECORD AND $LEVEL=TOKENLEVEL)
	  THEN ERROR("Need undeclared identifier for array declaration");
	ATOKEN←TOKEN; WORD_READ("[");
	DO BEGIN
	   IF ADIM=5 THEN ERROR("Cant have more than 5 fields in array declaration");
	   BOUNDS[ADIM*2+1]←$$GTANYEXP("for array dimension",#SC);
	   WORD_READ(":"); BOUNDS[ADIM*2+2]←$$GTANYEXP("for array dimension",#SC);
	   GTOKEN;
	   IF TOKEN≠"," AND TOKEN≠"]"THEN ERROR("Need , here"); ADIM←ADIM+1;
	   END UNTIL TOKEN="]";
	PLIST[NARRAY←NARRAY+1]←$ARRDCLPCODE(BOUNDS,OBTYPE,ADIM,
		NARRAY +(IF CURBLOCK THEN $TMPOFF ELSE $SYMOFF-1));
	ARRAYREC:#DIM[DIMREC←NEW_RECORD(ARRAYREC)]←ADIM;
	SYMLST[NARRAY]←MK_SYM(ATOKEN,OBTYPE,DIMREC,#ARRAY);
	GTOKEN(FALSE);
	IF TOKEN≠"," AND NOT FINAL THEN ERROR("Need a comma or semicolon here");
    END UNTIL FINAL;
    IF TOKEN=";" THEN STOKEN←TRUE;
    PARRAY←NULL_RECORD;
    IF CURBLOCK THEN
	BEGIN INTEGER I; RPTR(SYMBOL)S;
		FOR I←1 STEP 1 UNTIL NARRAY DO
			BEGIN
			INSRTSYMTREE(S←SYMLST[I],CURBLOCK);
			SYMBOL:OFFSET[S]←($TMPOFF←$TMPOFF+1);
			PARRAY←$APPEND(PARRAY,PLIST[I]);
			END;
	END
    ELSE BEGIN
	INTEGER I; RPTR(SYMBOL)TEMP;
		FOR I← 1 STEP 1 UNTIL NARRAY DO
			BEGIN
			ENSYM$(TEMP←SYMLST[I]);
			SYMBOL:OFFSET[TEMP]←$SYMOFF;$SYMOFF←$SYMOFF+1;
			PARRAY←$APPEND(PARRAY,PLIST[I]);
			END;
	END;
    $$PCODE←PARRAY;
    END "array declaration";



INTERNAL PROCEDURE DECLPROC (INTEGER OBTYPE);
	BEGIN
	GTOKEN;
	IF EQU(TOKEN,"PROCEDURE")
	    THEN PROCDECLPROC(OBTYPE)
	    ELSE IF EQU(TOKEN,"ARRAY")
		THEN ARRAYDECLPROC(OBTYPE)
		ELSE BEGIN
			STOKEN←TRUE;
			SIMPLEDECL(OBTYPE);
		     END;
	END;

INTERNAL PROCEDURE RETURNPROC;
	BEGIN RPTR(EXPR$)EXP;
	IF $COMPILE=0 THEN ERROR("RETURN can only be inside a block");
	EXP←NULL_RECORD; GTOKEN;
	IF TOKEN="(" THEN
		BEGIN EXP←$$GTEXPR; GTOKEN;
		      IF TOKEN≠")" THEN ERROR("Need right paren here");
		END
	ELSE STOKEN←TRUE;
	$$PCODE←$RTNPCODE(EXP);
	END;
!	setbase,wrist,gather,readwrist,setstiff;

INTERNAL PROCEDURE SETBASEPROC;
	$$PCODE←$SETBASEPCODE;

INTERNAL PROCEDURE WRISTPROC;
BEGIN	RPTR(SYMBOL) S;
	WORD_READ("("); GTOKEN;
	IF TOKENPTR=NULL_RECORD OR
		SYMBOL:TYPE[TOKENPTR]≠#SC OR
		SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
		OR ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]≠1
		THEN ERROR("Need one dimensioned scalar array in WRIST");
	S←TOKENPTR; WORD_READ(")");
	$$PCODE←$WRISTPCODE(S);
END;

IFC #GATHER THENC

PRESET_WITH "FX","FY","FZ","MX","MY","MZ","T1","T2","T3","T4","T5","T6","TBL";
STRING ARRAY GATHCODES[0:12];

INTERNAL PROCEDURE GATHERPROC;
BEGIN	INTEGER STATUS,I; INTEGER S1;
	WORD_READ("("); STATUS←0;
	DO BEGIN
	    GTOKEN;
	    FOR I←0 STEP 1 UNTIL 12 DO IF EQU(TOKEN,GATHCODES[I]) THEN DONE;
	    IF I>12 THEN ERROR("Unrecognized code found: ",TOKEN);
	    STATUS←STATUS LOR ('1 LSH I);
	    GTOKEN;
	END UNTIL TOKEN≠",";
	IF TOKEN≠")" THEN ERROR("Need right paren here");
	$$PCODE←$GATHERPCODE(STATUS);
END;
ENDC

IFC #WRIST THENC
INTERNAL PROCEDURE READWRISTPROC;
	BEGIN STRING COMMAND,FNAME; INTEGER VAL;
	IF $COMPILE≠0 THEN PRINT(CRLF,"WARNING: you should not put READWRIST
inside a block...",crlf,"We make no promises",CRLF);
	VAL←0;FNAME←NULL;
	WORD_READ("(");
	GTOKEN;
	COMMAND←TOKEN;
	IF EQU("CALIB",COMMAND) OR EQU("RENAMEFILE",COMMAND) THEN
		BEGIN
		GTOKEN;
		IF TOKEN≠"," THEN ERROR("Need comma after CALIB or RENAMEFILE");
		IF EQU(COMMAND,"CALIB") THEN
			BEGIN
			GTOKEN;
			VAL←INTSCAN(TOKEN,$BRCHR);
			IF VAL<1 OR VAL>6
				THEN ERROR("Calib code must be between 1 and 6");
			END
		ELSE FNAME←NAMEFILE;
		END
	ELSE IF EQU("SAVERAWDATA",COMMAND) THEN
		BEGIN
		STRING S; S←NULL;
		GTOKEN;
		IF TOKEN≠"," THEN ERROR("Need comma after SAVERAWDATA");
		GTOKEN;
		IF TOKEN≠"""" THEN ERROR("need double quote here");
		GTOKEN;
		WHILE TOKEN≠"""" DO BEGIN S←S&TOKEN&" "; GTOKEN; END;
		FNAME←S;
		END;
	WORD_READ(")");
	GTOKEN(FALSE);
	IF NOT FINAL THEN ERROR("This is an incomplete instruction")
	ELSE IF EQU(COMMAND,"READ") THEN
		$$PCODE←$RFORCEPCODE
	ELSE IF VAL←RWRIST(COMMAND,VAL,FNAME) THEN
		ERROR("ERROR in reading wrist",$WRMSG[VAL]);
	END;
ENDC

INTERNAL PROCEDURE SETSTIFFPROC;
BEGIN
	RPTR(EXPR$) ARRAY E[1:8];
	INTEGER NARGS;
	WORD_READ("("); NARGS←0;
	DO BEGIN
	    E[NARGS←NARGS+1]←$$GTANYEXP("argument in SETSTIFF",#SC);
	    GTOKEN;
	END UNTIL TOKEN≠"," OR NARGS=6;
	IF TOKEN≠"," THEN ERROR("Need comma here")
		ELSE E[7]←$$GTANYEXP("argument in SETSTIFF",#FR);
	GTOKEN;
	IF TOKEN≠")" THEN ERROR("Need right paren after 7th argument");
	E[8]←$SETSTFPCODE; 
	$$PCODE←$AAPPEND(E);
END;


INTERNAL PROCEDURE DDTPROC;
	$$PCODE←$DDTPCODE;

! 	vt05,print,prompt,abort;

INTERNAL PROCEDURE VT05PROC(INTEGER STATE);
	$$PCODE←$VT05PCODE(STATE);

RPTR(EXPR$)PROCEDURE PRINTCODE;
	BEGIN
	RPTR(EXPR$)P; P←NULL_RECORD;
	WORD_READ("(");
	DO BEGIN
	   GTOKEN;
	   IF TOKEN=dquote
	   THEN	BEGIN "string found"
		READTILL(dquote);
		P←$APPEND(P,$PRNPCODE(TOKEN))
		END
	   ELSE BEGIN "expression found"
		STOKEN←TRUE;
		P←$APPEND(P,$PRVPCODE($$GTEXPR));
		END;
	   GTOKEN;
	   END UNTIL TOKEN≠",";
	IF TOKEN≠")" THEN ERROR("Need ) for end of PRINT list");
	RETURN(P);
	END;

INTERNAL PROCEDURE PRINTPROC;
	$$PCODE←PRINTCODE;

INTERNAL PROCEDURE ABORTPROC;
	$$PCODE←$APPEND(PRINTCODE,$ABORTPCODE);

INTERNAL PROCEDURE PROMPTPROC;
	$$PCODE←$APPEND(PRINTCODE,$PROMPTPCODE);
!	affix,unfix;

INTERNAL PROCEDURE UNFIXPROC;
	BEGIN
	RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
	EX1←$$GTIDREF(#FR,FRM1,"first frame of unfix");
	IF SYMBOL:TYPE[FRM1]=#TR
	    THEN IF SYMBOL:ACCESS[FRM1]=#SIMPLE THEN FRM1←CNVRTR(FRM1,SYMBOL:PNAME[FRM1])
	    ELSE ERROR("UNFIX: need a simple trans or a frame here");
	WORD_READ("FROM"); ! change this to handle just UNFIX FRAME1;
	EX2←$$GTIDREF(#FR,FRM2,"second frame of UNFIX");
	IF SYMBOL:TYPE[FRM2]=#TR
	    THEN IF SYMBOL:ACCESS[FRM2]=#SIMPLE THEN FRM2←CNVRTR(FRM2,SYMBOL:PNAME[FRM2])
	    ELSE ERROR("UNFIX: need a simple trans or a frame here");
	$$PCODE←$UFXPCODE(EX1,EX2);
	END;

	! parses the instruction
	  AFFIX <frame_id> TO <frame_id> {AT TRANS(<rot>,<vector>)};

INTERNAL PROCEDURE AFFIXPROC;
	BEGIN 
	INTEGER AFFTYPE;RPTR(EXPR$)TEMP;
	RPTR(EXPR$)EX1,EX2; RPTR(SYMBOL)FRM1,FRM2;
	EX1←$$GTIDREF(#FR,FRM1,"first frame of affix");
	IF SYMBOL:TYPE[FRM1]=#TR
	    THEN IF SYMBOL:ACCESS[FRM1]=#SIMPLE THEN FRM1←CNVRTR(FRM1,SYMBOL:PNAME[FRM1])
	    ELSE ERROR("AFFIX: need a simple trans or a frame here");
	WORD_READ("TO"); 
	EX2←$$GTIDREF(#FR,FRM2,"second frame of affix");
	IF SYMBOL:TYPE[FRM2]=#TR
	    THEN IF SYMBOL:ACCESS[FRM2]=#SIMPLE THEN FRM2←CNVRTR(FRM2,SYMBOL:PNAME[FRM2])
	    ELSE ERROR("AFFIX: need a simple trans or a frame here");
	GTOKEN(FALSE);
	TEMP←NULL_RECORD;
	IF EQU(TOKEN,"AT")
	   THEN BEGIN "AT"
		TEMP←$$GTANYEXP("offset part of AFFIX statement",#FR);
		GTOKEN(FALSE);
		END "AT";
	IF FINAL 
	   THEN AFFTYPE←#RGDLK
	   ELSE BEGIN "D"
	        IF TOKEN="+" OR EQU(TOKEN,"NONRIGIDLY") THEN AFFTYPE← #NRGLK
		ELSE IF TOKEN="*" OR EQU(TOKEN,"RIGIDLY") THEN AFFTYPE← #RGDLK
		ELSE ERROR("invalid affix type");
	        SEMICOL_READ;  
	        END "D";
	$$PCODE←$AFXPCODE(EX1,EX2,AFFTYPE,TEMP);
	END ;

! 	coordproc;

INTERNAL PROCEDURE COORDPROC (INTEGER ELEMENT,TYPE);
	BEGIN
	RPTR(EXPR$) EX1,EX2; RPTR(SYMBOL) S;INTEGER TYPEF;
	S←NULL_RECORD;				! element=0,1,2,3 depending on instr;
	WORD_READ("(");
	EX1←IDREF(S);			! read the argument&look for predeclared;
	IF PRDECL(S) THEN 
		ERROR("You cannot change the value of"&SYMBOL:PNAME[S] );
	! check for correct type of argument;
	CASE (TYPEF←EXPR$:TYPE[EX1]) OF
		BEGIN
		[#SC][#RT] ERROR("unexpected type");
		[#VT] IF ELEMENT=0 THEN ERROR("unexpected type");
		ELSE 
		END;
	WORD_READ(")");
	WORD_READ("←");
	! reads the expression according to the type;
	CASE TYPE OF
		BEGIN
		[#SC] EX2←$$GTANYEXP("X-Y-Z coord",#SC);
		[#VT] EX2←$$GTANYEXP("POS",#VT);
		[#RT] EX2←$$GTANYEXP("ORIENT",#RT);
		ELSE ERROR("COORDPROC: unexpected type")
		END;
	$DISPLAYLIST[TYPEF]←NULL;
	$$PCODE←$COORDPCODE(EX1,EX2,ELEMENT,TYPE);
	END;

!	assignproc;

	! assigns to first the expression following, assuming that FIRST has not
	  been declared.  This works only for simple variables;
PROCEDURE ASGEX3(STRING FIRST);
	BEGIN RPTR(EXPR$)LHS,RHS; INTEGER TY; RPTR(SYMBOL)S; 
	RHS←$$GTEXPR;
	S←INSERT(FIRST,TY←EXPR$:TYPE[RHS]);
	LHS←EXPR$ID(S);
	$$PCODE←$ASGPCODE(LHS,RHS);
	END;

INTERNAL PROCEDURE ASGEX2(RPTR(SYMBOL)S;RPTR(EXPR$)LHS);
	BEGIN RPTR(EXPR$)RHS; INTEGER TY;
	RHS←$$GTEXPR;
	IF (TY←SYMBOL:TYPE[S])=#FR AND EXPR$:TYPE[RHS]=#TR THEN
	    EXPR$:TYPE[RHS]←#FR
	   ELSE IF TY=#TR AND EXPR$:TYPE[RHS]=#FR
		THEN CNVRTR(S,SYMBOL:PNAME[S])
	   ELSE IF EXPR$:TYPE[RHS]≠TY THEN ERROR("INCOMAPTABILE TYPE ASSIGNMENT");
	$$PCODE←$ASGPCODE(LHS,RHS);
	END;

PROCEDURE ASGMNT(RPTR(SYMBOL)S;RPTR(EXPR$)EE);
	IF PRDECL(S) THEN
		ERROR("You cannot change the value of "&SYMBOL:PNAME[S])
		ELSE ASGEX2(S,EE);
	
INTERNAL PROCEDURE ASSIGNPROC;
	BEGIN STRING FIRST; RPTR(SYMBOL)SS; RPTR(EXPR$)EE;
	FIRST←TOKEN;  EE←NULL_RECORD;
 	IF (SS←TOKENPTR)≠NULL_RECORD THEN
		IF SYMBOL:ACCESS[TOKENPTR]=#PROCEDURE
			THEN BEGIN $$PCODE←PREF(TOKENPTR);
				RETURN; END
		ELSE BEGIN STOKEN←TRUE; EE←IDREF(SS); END;
	GTOKEN;
	! EE=NULL_RECORD implies is an undeclared id;
	IF TOKEN="←"
	  THEN IF EE THEN ASGMNT(SS,EE)
		     ELSE IF $LEVEL=0 THEN ASGEX3(FIRST)
				 ELSE ERROR("Cant make implicit declaration inside a block")
	   ELSE ERROR("unrecognized instruction");
	END;
! 	deflt;

INTERNAL PROCEDURE DEFLT(STRING HOW);
	BEGIN
	IF EQU(OLDCMD,"OPEN") OR EQU(OLDCMD,"CLOSE")
	   THEN OPENING(OLDCMD,OLDOBJ,HOW)
	ELSE IF EQU(OLDCMD,"MOVEX")OR EQU(OLDCMD,"MOVEY")OR EQU(OLDCMD,"MOVEZ")
		THEN IF HOW="BY"
			THEN ALONGPROC(OLDCMD[5 FOR 1],OLDOBJ)
			ELSE ERROR("BY required")
	ELSE IF EQU(OLDCMD,"DRIVE")
		THEN JTMOVE("BJT",HOW,CVD(OLDOBJ))
	ELSE IF EQU(OLDCMD,"MOVE") 
		THEN IF EQU(HOW,"BY") THEN PBYPROC ELSE PTOPROC;
	END;

END "PPROC";